(library (exceptions)
  (export make-contract-violated-exception-plain
          make-exception-contract-violated-compound
          &contract-violated
          contract-violated-exception?)
  (import (except (rnrs base) let-values)
          (only (guile)
                lambda* λ
                record-constructor
                make-exception-type
                &programming-error)
          (ice-9 exceptions))

  ;; Create a custom exception type, to make it clearer,
  ;; that a contract failed, and not only an arbitrary
  ;; assertion.
  (define &contract-violated
    (make-exception-type
     ;; name of the new exception type
     '&contract-violated
     ;; parent exception type
     &programming-error
     ;; list of values the constructor of the exception
     ;; takes and their names in the record
     '()))

  (define make-contract-violated-exception-plain
    ;; record-constructor is a procedure, which will return
    ;; the constructor for any record.
    (record-constructor
     ;; Create an exception type, which is a record. This
     ;; record has a constructor, which we can name using
     ;; define for example.
     &contract-violated))

  (define contract-violated-exception?
    (exception-predicate &contract-violated))

  (define make-exception-contract-violated-compound
    (λ (message origin irritants)
      (make-exception
       (make-contract-violated-exception-plain)
       (make-exception-with-message message)
       (make-exception-with-origin origin)
       (make-exception-with-irritants irritants)))))
